home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 July / Macworld (1999-07).dmg / Shareware World / Info / For Developers / Mops 3.4.sea / Mops source / Module source / Extrasmod.txt < prev    next >
Text File  |  1998-01-27  |  13KB  |  570 lines
  1. \ This module implements a number of words that we need only at compile time,
  2. \ or only in the Mops development environment.
  3.  
  4.  
  5. \        ======== Display of source code ========
  6.  
  7. \ The display is rather crude, but at least you can see the source.
  8. \ If AppleEvents are available, we do a lot better and send an AE to
  9. \ Quick Edit to open the file at the given position, and then we don't
  10. \ use the display code here.  (And good riddance, too.)
  11.  
  12. false    value    LOG_THERE?
  13. false    value    SRC_THERE?
  14. false    value    USE_MOD?
  15. false    value    QE?
  16.  
  17. :class  FSSpec  super{ object }
  18. record
  19. {    int        vRefNum
  20.     var        parID
  21. 64    bytes    filename
  22. }
  23.  
  24. :m getVref:        get: vRefNum    ;m
  25. :m getDirID:    get: parID        ;m
  26.  
  27. :m setVref:        put: vRefNum    ;m
  28. :m setDirID:    put: parID        ;m
  29. :m name:        64 min  addr: fileName  >str255  drop  ;m
  30. :m getName:        addr: fileName  count  ;m
  31.  
  32.  
  33. :m NEW:
  34.     word0
  35.     int: vRefNum  get: parID  addr: filename  ^base
  36.     call FSMakeFSSpec  i->l  ;m
  37.  
  38. ;class
  39.  
  40.  
  41. FSSpec  FS
  42.  
  43. objPtr    THEMOD  class_is module
  44.  
  45. window    DW
  46.  
  47. file    LOG
  48. file    SRC
  49. file    QEF
  50.  
  51. string+    DSP
  52. string+    S
  53. string+    $TMP
  54. string+    $LOG
  55. string+    $PRF
  56.  
  57. 0    value    CURS_POS
  58. 0    value    CURS_ROW
  59. 0    value    CURS_COL
  60.  
  61. 0    value    MK_CFA
  62. 0    value    TOPDIR
  63. 0    value    TOPDATE
  64.  
  65.  
  66. : OPEN_SRC_WINDOW
  67.     QE?  ?EXIT                \ If we're showing the source in QE, out
  68.     s copyto: dsp
  69.     2 38  494 170  put: tempRect
  70.     tempRect  " "
  71.     docWind  true true  new: dw
  72.     screenbits true setGrow: dw
  73.     setFwind
  74.     true -> src_there?  ;
  75.     
  76.  
  77. : SET_DSP  { \ cr? -- }
  78.     true -> cr?
  79.     s  copyto: dsp
  80.     curs_pos >pos: dsp
  81.     2 0 DO  <nextline?: dsp  NIF  LEAVE  THEN  LOOP
  82.     pos: dsp
  83.     10 0 ?DO
  84.         nextline?: dsp  NIF  false -> cr?  LEAVE  THEN
  85.     LOOP
  86.     >pos: dsp
  87.     cr? more: dsp  ;
  88.  
  89.  
  90. local DISPLAY  { disp? \ redraw? end_disp curs_line_pos 1st? -- }
  91.  
  92. : (DISP)
  93.     0 -> curs_row  0 -> curs_line_pos  true -> 1st?
  94.     disp? IF  4 tFont  9 tSize  -curs  cls  THEN        \ Monaco 9
  95.     BEGIN
  96.         nextline?: dsp  0EXIT
  97.         lim: dsp  end_disp  > ?EXIT
  98.         1st? IF  false -> 1st?  ELSE  disp? IF cr THEN  THEN
  99.         lim: dsp  curs_pos  <
  100.         IF  1 ++> curs_row  lim: dsp 1+  -> curs_line_pos  THEN
  101.         disp? IF  get: dsp  type  THEN
  102.     AGAIN  ;
  103.  
  104. : SHOW_CURS
  105.     +curs  disp? NIF  .cur  THEN        \ If just updating, erase curs
  106.     curs_pos curs_line_pos -  dup -> curs_col 1+  6 *    \ x
  107.     curs_row 1+ #lead *  6 +                \ y
  108.     gotoxy  .cur  ;
  109.  
  110. : (DISPLAY)
  111.     lim: dsp  -> end_disp
  112.     save: dsp  0 >len: dsp
  113.     (disp)
  114.     restore: dsp  ;
  115.  
  116.  
  117. :loc DISPLAY          \    { disp? \ redraw? end_disp curs_line_pos 1st? -- }
  118.  
  119.     QE?
  120.     IF    qef  curs_pos dup   openFile: tQE  0EXIT
  121.         false -> QE?            \ failed - assume QE has gone away
  122.         open_src_window
  123.     THEN
  124.     src_there?  0EXIT
  125.     pushPort  set: dw
  126.     (display)
  127.     curs_row 0=  pos: dsp  0<>  and  -> redraw?
  128.     curs_row 6 >  lim: dsp  size: dsp  <  and  --> redraw?
  129.     redraw? IF  set_dsp  update: dw  THEN
  130.     show_curs
  131.     popPort  ;loc
  132.  
  133. ' redraw  setdraw: dw        \ Note: this must refer to the EXPORTED
  134.                             \ version of redraw.
  135.  
  136. : REDRAW    true  display  ;
  137. : UPD        false display  ;
  138.  
  139. : 1UP
  140.     curs_pos 1-  0 max  dup >pos: s >lim: s
  141.     <nextline?: s  0EXIT
  142.     pos: s  dup IF  1+  THEN  -> curs_pos  upd  ;
  143.  
  144. : 1DN
  145.     curs_pos dup >pos: s >lim: s
  146.     nextline?: s  0EXIT
  147.     lim: s 1+  -> curs_pos  upd  ;
  148.  
  149. : 1LFT    ;    \ Really not much point in implementing these!
  150. : 1RT   ;
  151.  
  152. : HOMEx        0    -> curs_pos  upd  ;
  153. : END        size: s    -> curs_pos  upd  ;
  154.  
  155. : DEFNUP  { \ posn -- }
  156.     curs_pos 1-  0 max  dup  >pos: s  >lim: s
  157.     BEGIN
  158.         <nextline?: s  0EXIT
  159.         pos: s  -> posn  posn IF  1 ++> posn  THEN
  160.         ptr: s  posn +  c@  & :  =
  161.         IF  posn -> curs_pos  upd  EXIT  THEN
  162.     AGAIN  ;
  163.  
  164. : DEFNDN
  165.     curs_pos  dup  >pos: s  >lim: s
  166.     BEGIN
  167.         nextline?: s  0EXIT
  168.         ^1st: s  1+  c@  & :  =
  169.         IF  pos: s  1+  -> curs_pos  upd  EXIT  THEN
  170.     AGAIN  ;
  171.  
  172.  
  173. \ ADDR>CURS is exported.  It takes a dictionary address, and tries to
  174. \ convert it to the corresponding "cursor" position in the source file.
  175. \ If we have a source window open, it updates the cursor position in
  176. \ that window as well.
  177.  
  178. : ADDR>CURS  { addr \ offs -- curs-pos }
  179.     log_there?  NIF  0  EXIT  THEN
  180.     addr filestart_dp -  -> addr   0 -> offs
  181.     reset: $log
  182.     BEGIN
  183.         len: $log  0<=  IF  0  EXIT  THEN
  184.         ^1st: $log  w@  addr >
  185.         IF  ( found )
  186.             offs -> curs_pos  upd   offs  EXIT
  187.         THEN
  188.         ^1st: $log  2+  @  -> offs
  189.         6 skip: $log
  190.     AGAIN  ;
  191.  
  192.  
  193. : MOVE_CURS        \ ( pos -- )    Exported.
  194.     -> curs_pos  upd  ;
  195.  
  196.  
  197. : SELECTDW            \ Exported.
  198.     src_there?  0EXIT
  199.     select: dw  ;
  200.  
  201.  
  202. : CHK_DATE
  203.     getFileInfo: src  OK?  src 76 + @
  204.     use_mod?
  205.     IF
  206.         base: theMod  @
  207.     ELSE
  208.         mk_cfa 6 + @  ?dup NIF -1 THEN
  209.     THEN
  210.     u>
  211.     IF
  212.         3 beep  cr  msg# 76    \ "Source later than compiled version"
  213.     THEN  ;
  214.  
  215.  
  216. \ ?OPEN_IN_QE is exported.  It sees if the passed-in file can be opened
  217. \ in Quick Edit via an AppleEvent.  The value QE? is left indicating
  218. \ the result.  It's not a serious problem if we can't find the file, but
  219. \ it's nice if we can.
  220.  
  221. : ?OPEN_IN_QE  { ^file -- }
  222.     false -> QE?
  223.     AppleEvents?  0EXIT
  224.     getname: [ ^file ]  name: FS
  225.     0 setVref: FS  0 setDirID: FS
  226.     new: FS
  227.     IF        \ An error occured.  The file might have been opened via
  228.             \  standard file.  In this case, topDir will be set.  Let's
  229.             \  try...
  230.         getName: [ ^file ]
  231.         name: FS
  232.         0 setVref: FS  topDir setDirID: FS
  233.         new: fs   ?EXIT            \ Out if we still can't find it
  234.     THEN
  235.     
  236.     getName: FS  name: qef
  237.     getVref: FS  setVref: qef
  238.     getDirID: FS  setDirID: qef
  239.     qef 0 0   openFile: tQE    ?EXIT
  240.                         \ If AE send failed, maybe QE isn't there at all!
  241.     true -> QE?  ;
  242.         
  243.  
  244. : (OPEN_SRC)
  245.     2dup  put: $tmp  name: src
  246.     use_mod?
  247.     NIF
  248.         mk_cfa @  setDirID: src
  249.     THEN
  250.     openReadOnly: src  ?EXIT      \ Out on error
  251.     chk_date
  252.     src  readAll: s                \ read source - we do this even if we can
  253.     close: src drop                \  open it in QE, since we might need it for
  254.                                 \  PROFILE or something
  255.     src ?open_in_QE
  256.     QE?  ?EXIT
  257.     open_src_window
  258.     get: $tmp  title: dw
  259.     0 -> curs_pos  set_dsp  update: dw  ;
  260.  
  261.  
  262. : SRC_NAME
  263.     mk_cfa >name n>count 1-  ;
  264.  
  265. : OPEN_SRC
  266.     src_name  (open_src)  ;
  267.  
  268. : OPEN_SRC_IN_MOD
  269.     txtName: theMod  (open_src)  ;
  270.  
  271.  
  272. \ The following words are used in conjunction with Quick Edit.
  273.  
  274. \ EDIT is exported.  It opens the given file in QE if possible.
  275. \ Usage:  edit xxxx
  276.  
  277. : EDIT
  278.     setName: src
  279.     openReadOnly: src          \ Get full pathname.
  280.     ?error 66                \ "couldn't find source file"
  281.     src ?open_in_QE
  282.     close: src  drop
  283.     QE? not  ?error 67        \ "Quick Edit not open or sys7 not running"
  284. ;
  285.  
  286. \ OPENSOURCE is exported.  This word is called from QE, so we can assume
  287. \ QE is there.  QE is asking us to identify the source file for the given
  288. \ word, and then call QE back to open that file.  The format of the string
  289. \ sent from QE (located in QEstr) is  FindSource xxxxx.  At this point
  290. \ we're EVALUATEing, and have parsed the FindSource, so we can now
  291. \ simply call DEFINED?.
  292. \ Note: this word is also called LOCATE, which I now think is a better name.
  293.  
  294. : OPENSOURCE
  295.     defined?
  296.     IF    locate_src
  297.     ELSE
  298.         1 beep
  299.         reset: QEstr
  300.         11 skip: QEstr      \ skip over OpenSource 
  301.         get: QEstr type space  ." not defined!!"
  302.     THEN  ;
  303.  
  304.  
  305. \ def?? is exported.  It's needed by the QE special menu item def??
  306.  
  307. : def?? \ 19Dec93 DBH slightly changed to show us the word in question and
  308.         \  display the answer
  309.     reset: QEstr
  310.     6 skip: QEstr  \ skip over def?? 
  311.     get: QEstr type space
  312.     defined?
  313.     nip
  314.     IF        ." defined"
  315.     ELSE    ." not defined!!"
  316.     THEN ;
  317.  
  318.  
  319. \        ========== end of QE-related words =============
  320.  
  321.  
  322. : (CREATE_LOG)
  323.     here -> filestart_dp
  324.     new: $lg1  new: $lg2
  325.     $ B3010000 pad !    \ Unique marker for log files | version
  326.     false -> relocChk?
  327.     here pad 4+ reloc!
  328.     true -> relocChk?
  329.     pad 8  put: $lg1  ;
  330.  
  331.  
  332. : (WRITE_LOG)        \ Called to write out the log and profile strings to the
  333.             \  2 corresponding files
  334.     getname: topfile  put: $tmp
  335.     " .log"  add: $tmp
  336.     all: $tmp  name: log
  337.     use_mod?  IF  0  ELSE  topDir  THEN
  338.     setDirID: log
  339.         \ OK to use zero for modules, since the module's source
  340.         \ file name will be fully qualified.
  341.     create: log  ?dup
  342.     IF  . space ." I/O err creating log file " abort  THEN
  343.     0 setDirID: log
  344.     'type SLOG  'type Mops  set: log
  345.     reset: $lg1  len: $lg1  ^1st: $lg1 2+  w!
  346.     all: $lg1  write: log  OK?
  347.     all: $lg2  write: log  OK?
  348.     close: log  OK?
  349.     release: $lg1  release: $lg2  ;
  350.  
  351.  
  352. : OPEN_LOG            \ Exported (for error handling)
  353.     false -> log_there?
  354.     clear: $log  clear: $prf
  355.     use_mod?
  356.     IF
  357.         " .txt.log" extname: theMod  put: $tmp
  358.         all: $tmp  name: log
  359. \        base: theMod 4+ @  setDirID: log
  360.     ELSE
  361.         mk_cfa 4+  w@
  362.         NIF  ( No log file )
  363.             clear: $log  EXIT
  364.         THEN
  365.         " .log" add: $tmp
  366.         all: $tmp  name: log  0 setVref: log
  367.         mk_cfa @  setDirID: log
  368.     THEN
  369.     openReadOnly: log  ?EXIT        \ If error, maybe log not there.
  370.     pad 8 read: log  OK?
  371.     pad w@  $ B301 =  0EXIT            \ Out if not valid log file
  372.     true -> log_there?
  373.     use_mod?
  374.     IF
  375.         base: theMod
  376.         #imp: theMod  2* +  8 +
  377.     ELSE
  378.         pad 4+ @abs
  379.     THEN
  380.     -> filestart_dp
  381.     log  pad 2+ w@ 8 -  readN: $log
  382.     log  readRest: $prf  close: log  drop
  383. \    rd: $log  rd: $prf
  384. \    set: fwind  dump: $log  set: dw        \ debugging only
  385.     src_there? IF  redraw  THEN
  386.     true -> log_there?  ;
  387.  
  388.  
  389. : CL        \ Close src and log etc.
  390.     src_there?  0EXIT
  391.     close: dw  release: s  release: $tmp  release: $log  release: $prf
  392.     close: src drop
  393.     false -> log_there?  false -> src_there?  false -> QE?
  394.     setFwind
  395.     drop: extrasmod  ;
  396.  
  397.  
  398. : (FINDMK)        \ ( cfa 0 -- )
  399.     drop  dup -> mk_cfa  2- w@x file-mark = -> endTrav?  ;
  400.     
  401. : FIND_MARK?    \ ( start-addr -- )
  402.     ['] (findmk)  0  rot  trav-from
  403.     endTrav?  ;
  404.  
  405.  
  406. : LOCATE_SRC  { theCfa -- }        \ Exported.  Opens source window for given
  407.                                 \ definition, if possible.
  408.     lock: extrasmod        \ Since we have a window, and windows
  409.                         \ mustn't move!
  410.     use_mod?
  411.     NIF    theCfa find_mark?
  412.         NIF
  413.             src_there?  IF  cl  THEN  EXIT
  414.         THEN
  415.     THEN
  416.     use_mod?
  417.     IF    open_src_in_mod  open_log
  418.         false -> use_mod?    \ For next time
  419.     ELSE
  420.         open_src  open_log
  421.     THEN
  422.     QE? IF  theCfa >name n>count  find: tQE  drop  THEN  ;
  423.  
  424.  
  425. : USE_MODULE    \ ( ^mod -- )
  426.     -> theMod  true -> use_mod?  ;
  427.  
  428. : PROF_STR    \ Exported - called by DebugMod to get hold of the profile
  429.             \  string and source string.
  430.     reset: $prf  reset: s
  431.     $prf  s  ;
  432.  
  433.  
  434. \            ======== Code for loading and reloading =========
  435.  
  436. : PURGE_INIT_ACTIONS  { \ index -- }
  437.             \ We call this before reloading, to get rid of any
  438.             \ invalid entries out of INIT_ACTIONS.
  439.     0 -> index
  440.     BEGIN
  441.         index  size: init_actions  >=  ?EXIT
  442.         index  ^elem: init_actions  @abs  here u>
  443.         IF    index  remove: init_actions
  444.         ELSE    1 ++> index
  445.         THEN
  446.     AGAIN  ;
  447.  
  448.  
  449. : <CS  { addr len c \ offs -- addr len offs }
  450.     len -> offs
  451.     addr  addr len + 1-  DO
  452.         i c@  c = IF  LEAVE  THEN
  453.         -1 ++> offs
  454.     -1 +LOOP
  455.     addr len offs  ;
  456.  
  457.  
  458. : +LOG        true  -> log?  ;
  459. : -LOG        false -> log?  ;
  460.  
  461.  
  462. \ SAVE-LOAD is a smarter variant of mark_file which we use
  463. \  to put a file mark in the dic at the start of each load.
  464. \ It includes the dirID, whether logged, and the date/time
  465. \  loaded.
  466.  
  467. : SAVE-LOAD
  468.     getName: topFile  put: $tmp  bl +: $tmp  reset: $tmp
  469.     & :  <chsearch: $tmp  negate skip: $tmp
  470.     get: $tmp
  471.     
  472.     crossed?
  473.     IF    ppc_sHdr
  474.         file-mark codeW,            \ file-mark is the "handler code"
  475.         topDir code,
  476.         log? codeW,
  477.         topDate code,
  478.     ELSE
  479.         sHdr  file-mark w,
  480.         topDir ,  log? w,  topDate ,
  481.     THEN
  482.     release: $tmp  ;
  483.  
  484.  
  485. : LOADIT  { \ svCurs -- }
  486. \    watchcurs        - now inappropriate with TEFwind
  487.     purge_init_actions
  488.     curs -> svCurs -curs
  489.     getFileInfo: topFile  NIF  topFile 76 + @  ELSE  0  THEN  -> topDate
  490.     clear: topFile
  491.     topDir  setDirID: topFile
  492.     save-load
  493.     MBcomp LdFromMod  drop: loadFile
  494. \    log?  IF  -log  THEN
  495.     svCurs -> curs
  496. \    arrowcurs
  497. ;
  498.  
  499.  
  500. : L         \ Load
  501.     pushNew: loadfile
  502.     'type TEXT 1 stdget: topfile
  503.     IF    getDirID  dup  setDirID: topFile  -> topDir
  504.         loadit
  505.     ELSE
  506.         clear: loadfile
  507.     THEN  ;  
  508.  
  509. : FM        \ Forget to mark
  510.     here find_mark?  not abort" No mark!"
  511.     mk_cfa >link (forget)  ;
  512.  
  513. : RL
  514.     here find_mark?  not abort" L not done!"
  515.     cl        \ Close source window if open as it probably
  516.             \ won't be valid any more.
  517.     pushnew: loadfile
  518.     src_name  name: topFile
  519.     mk_cfa @  dup  -> topDir  setDirID: topFile
  520. \    mk_cfa 4+ w@x  ++> log?
  521.     mk_cfa >link (forget)  loadit  ;
  522.  
  523.  
  524.  
  525. \ Put NEED xxx or " xxx" INCLUDED  at any point where the file of name
  526. \ xxx is to be already loaded.  If it hasn't already been loaded, it
  527. \ is loaded at that point.
  528.  
  529. \ Note that only one blank or tab is allowed between NEED and the ilename.
  530. \ This is because we use WORD" to read the filename, so that names with
  531. \ embedded blanks are allowed.
  532.  
  533. : INCLUDED  { \ svLog svTopDir svTopDate -- }
  534.     put: $tmp  bl +: $tmp  reset: $tmp
  535.     & :  <chsearch: $tmp  negate skip: $tmp
  536.     get: $tmp  sFind  nip
  537.     IF  release: $tmp  EXIT  THEN    \ Found - nothing else to do
  538.     
  539.                                     \ Not found - load it
  540.     latest name> 2- w@x  file-mark =
  541.     IF                \ That was a file-mark - forget it so RL
  542.                     \  won't make us reload NEEDed files
  543.         latest n>link (forget)
  544.     THEN
  545.     pushnew: loadFile  get: $tmp  1-  name: topfile
  546.     release: $tmp
  547.     log? -> svLog
  548.     -log                            \ Don't log NEEDed file
  549.     openReadOnly: topFile  ?file_open_error
  550.     close: topFile  drop
  551.     getFileInfo: topFile  ?file_open_error
  552.     topDate -> svTopDate
  553.     topDir -> svTopDir
  554. \    getDirID: topFile  -> topDir    \ I'm not too sure why this doesn't work
  555.     0 -> topDir
  556.     clear: topFile                    \ Leaves name field intact
  557.     loadit                            \ Load NEEDed file
  558.     svLog IF  +log  THEN
  559.     svTopDate -> topDate
  560.     svTopDir  -> topDir
  561.     size: loadFile IF  save-load  THEN
  562. ;
  563.  
  564. : NEED  ( --<filename> )
  565.     word"  count                \ Get name from input
  566.     included  ;
  567.  
  568.  
  569. ' cl  setrelease
  570.